; LambdaStyle source checks
(import 'java.lang.Character)

(define (get-type-code type)
   (if (symbol? type)
      (case type
         ((LITERAL_INT LITERAL_SHORT LITERAL_BYTE) "n")
         ((LITERAL_BOOLEAN) "b")
         ((LITERAL_LONG) "l")
         ((LITERAL_CHAR) "ch")
      )
      (when (and (eq? 'IDENT (car type)) (string=? "String" (cadr type)))
         "s"
      )
   )
)

(define constant-pattern (string-pattern "[A-Z]+(_[A-Z]+)*"))

(define (validate-hungarian node)
   (assert (eq? (car node) 'VARIABLE_DEF))
   (let*
      (
         (ident (find-first 'IDENT node))
         (name (cadr ident))
         (type (cadr (find-first 'TYPE node)))
         (isArray
            (and
               (pair? type)
               (eq? 'ARRAY_DECLARATOR (car type))
            )
         )
         (type-code
            (if isArray
               (get-type-code (cadr type))
               (get-type-code type)
            )
         )
         (isPrimitive (not (null? type-code)))
      )
      (when isPrimitive
         (unless
            (if (name'startsWith type-code)
               (or
                  (= (string-length type-code) (string-length name))
                  (java.lang.Character'isUpperCase (string-ref name (string-length type-code)))
               )
               (if (not isArray)
                  (case type
                     ((LITERAL_INT) (in? name "i" "k" "m" "n"))
                     (else #f)
                  )
                  #f
               )
            )
            (annotate node "Variable name must begin with \"{0}\" <{1}>" type-code node)
         )
      )
   )
)

(lambda (root)
   (when
      (and
         (eq? (car root) 'CLASS_DEF)
         ; Skip private inner classes
         (or
            (top-level? root)
            (and
               (not (top-level? root))
               (let*
                  (
                     (modifiers (find-first 'MODIFIERS root))
                     (isPrivate (if (list? modifiers)
                        (not (eq? #f (memq 'LITERAL_PRIVATE modifiers)))
                        (error "Not a list" modifiers root)
                     ))
                  )
                  isPrivate
               )
            )
         )
      )
      (for-each
         (lambda (node)
            (when (pair? node)
               (case (car node)
                  (
                     (VARIABLE_DEF)
                     (let*
                        (
                           (ident (find-first 'IDENT node))
                           (identifier (cadr ident))
                           (modifiers (find-first 'MODIFIERS node))
                           (isStatic (if (list? modifiers)
                              (not (eq? #f (memq 'LITERAL_STATIC modifiers)))
                              (error "Not a list" modifiers node)
                           ))
                           (isFinal (not (eq? #f (memq 'FINAL modifiers))))
                           (prefix (substring identifier 0 2))
                           (type (cadr (find-first 'TYPE node)))
                           (isArray
                              (and
                                 (pair? type)
                                 (eq? 'ARRAY_DECLARATOR (car type))
                              )
                           )
                           (type-code
                              (if isArray
                                 (get-type-code (cadr type))
                                 (get-type-code type)
                              )
                           )
                           (isPrimitive (not (null? type-code)))
                           (validate-hungarian
                              (lambda (name)
                                 (when isPrimitive
                                    (unless
                                       (if (name'startsWith type-code)
                                          (or
                                             (= (string-length type-code) (string-length name))
                                             (java.lang.Character'isUpperCase (string-ref name (string-length type-code)))
                                          )
                                          #f
                                       )
                                       (annotate ident "Field name must begin with \"{0}\"" type-code)
                                    )
                                 )
                              )
                           )
                        )
                        (if isStatic
                           (if isFinal
                              (unless
                                 (or
                                    (string=? identifier "serialVersionUID")
                                    (string=? identifier "s_logger")
                                    (string-match identifier constant-pattern)
                                 )
                                 (annotate ident "Constants must be capitalized, with _ between words")
                              )
                              (if (string=? prefix "s_")
                                 (validate-hungarian (substring identifier 2 (string-length identifier)))
                                 (begin
                                    (annotate ident "Static field must begin with s_")
                                    (validate-hungarian identifier)
                                 )
                              )
                           )
                           (if (string=? prefix "m_")
                              (validate-hungarian (substring identifier 2 (string-length identifier)))
                              (begin
                                 (annotate ident "Instance field must begin with m_")
                                 (validate-hungarian identifier)
                              )
                           )
                        )
                     )
                  )
                  (
                     (METHOD_DEF)
                     (let*
                        (
                           (methodName (cadr (find-first 'IDENT node)))
                           (body (find-first 'SLIST node))
                        )
                        (logger'info methodName ":" body)
                        (for-all-recursive 'VARIABLE_DEF body validate-hungarian)
                     )
                  )
               )
            )
         )
         (find-first 'OBJBLOCK root)
      )
   )
)

